home *** CD-ROM | disk | FTP | other *** search
/ HyperLib 1997 Winter - Disc 1 / HYPERLIB-1997-Winter-CD1.ISO.7z / HYPERLIB-1997-Winter-CD1.ISO / オンラインウェア / PRG / PowerLisp 2.01 FAT Folder.sit / PowerLisp 2.01 FAT Folder / PowerLisp 2.01 ƒ / Library / cl.lisp < prev    next >
Lisp/Scheme  |  1996-05-22  |  47KB  |  1,796 lines
  1. ;;;
  2. ;;;        PowerLisp 2.0
  3. ;;;        Copyright ｩ 1996 Roger Corman.  All rights reserved.
  4. ;;;        Common Lisp library source
  5. ;;;
  6.  
  7. ;
  8. ;        Lisp standard functions and macros to be loaded at startup.
  9. ;
  10.  
  11. (eval-when (:compile-toplevel :load-toplevel :execute)
  12.     (in-package :common-lisp))
  13.  
  14. (eval-when (:compile-toplevel :load-toplevel :execute)
  15. (export '(    when 
  16.             unless 
  17.             prog1 
  18.             prog2
  19.             loop 
  20.             assert
  21.             warn
  22.             push 
  23.             pushnew
  24.             pop 
  25.             ecase
  26.             incf 
  27.             decf 
  28.             remf
  29.             rotatef
  30.             multiple-value-list 
  31.             multiple-value-setq
  32.             multiple-value-bind
  33.             functionp keywordp arrayp packagep bit-vector-p
  34.             string
  35.             position position-if position-if-not
  36.             find find-if find-if-not
  37.             count count-if count-if-not
  38.             fill replace
  39.             mismatch search
  40.             svref array-rank-limit array-dimension-limit array-total-size-limit
  41.             most-positive-fixnum most-negative-fixnum
  42.             print prin1 princ pprint
  43.             mapcan
  44.             mapcon
  45.             copy-alist
  46.             read-from-string
  47.             with-output-to-string
  48.             read-function
  49.             prompt *prompt* 
  50.             disassemble
  51.             print-addr
  52.             print-code
  53.             copyright
  54.             require
  55.             provide
  56.             defasm
  57.             hex
  58.             compile
  59.             compile-file
  60.             compile-without-assembling
  61.             identity
  62.             finish-output force-output clear-output
  63.             parse-integer
  64.             psetq
  65.             do
  66.             do*
  67.             *features*
  68.             *modules*
  69.             *load-verbose*
  70.             *load-print*
  71.             *print-radix*
  72.             *print-circle*
  73.             *print-pretty*
  74.             *print-length*
  75.             *print-gensym*
  76.             *print-array*
  77.             *gc-verbose*
  78.             *lisp-file-extension*
  79.             *lisp-compiled-file-extension*
  80.             *library-directory*
  81.             *top-level*
  82.             *query-io*
  83.             lambda-list-keywords
  84.             pi
  85.             internal-time-units-per-second
  86.             defun defmacro deftype defstruct defpackage
  87.             defclass defgeneric defmethod    ;; clos macros
  88.             time
  89.             ffloor fceiling ftruncate fround
  90.             signum phase
  91.             typecase
  92.             describe
  93.             get-properties copy-symbol
  94.             do-symbols do-all-symbols do-external-symbols find-all-symbols
  95.             logtest cis asinh acosh atanh
  96.             butlast nbutlast list-length
  97.             lisp-implementation-type lisp-implementation-version
  98.             machine-type machine-version machine-instance
  99.             software-type software-version 
  100.             short-site-name long-site-name
  101.             error-stack
  102.             declaim
  103.             string-trim string-right-trim string-left-trim
  104.             remove-duplicates delete-duplicates
  105.             y-or-n-p yes-or-no-p values-list))
  106. ) ;; close eval-when
  107.             
  108. (setq *print-case* :downcase)    ; can be :upcase, :downcase or :capitalize
  109.  
  110. ; Some Common Lisp special variables
  111. (defvar *features* '(powerlisp))
  112. (defvar *modules* nil)
  113. (defvar *read-suppress* nil)
  114. (defvar *top-level* nil)
  115. (defvar *print-radix* nil)
  116. (defvar *print-circle* nil)
  117. (defvar *print-pretty* nil)
  118. (defvar *print-length* nil)
  119. (defvar *print-gensym* t)
  120. (defvar *print-array* t)
  121.  
  122. ;
  123. ;    The *library-directory* special variable is used by
  124. ;    the 'require' function to figure out where to load 
  125. ;    requested modules from.
  126. ;
  127. (defconstant *library-directory* ":library:") 
  128. (defconstant *lisp-file-extension* ".lisp")
  129. (defconstant *lisp-compiled-file-extension* 
  130.     (if cl::%powerpc-native ".ppcl" ".fasl"))
  131. (defconstant lambda-list-keywords
  132.     '(&optional &rest &key &allow-other-keys &aux &body &whole &environment)) 
  133.  
  134. (defun lisp-implementation-type () "PowerLisp")
  135. (defun lisp-implementation-version () "2.0")
  136. (defun machine-type () "Macintosh")
  137. (defun machine-version () (if cl::%powerpc-native "Power Macintosh" "68k Macintosh"))
  138. (defun machine-instance () "Your mac!")
  139. (defun software-type () "Macintosh OS")
  140. (defun software-version () "7.5")
  141. (defun short-site-name () "Here")
  142. (defun long-site-name () "Wherever you go")
  143.  
  144. (defconstant most-positive-fixnum (1- (ash 1 30)))
  145. (defconstant most-negative-fixnum (- most-positive-fixnum))
  146.  
  147. (defun compile (name &optional definition)
  148.     "Usage: (COMPILE function-name &optional lambda)"
  149.     (require :compiler)
  150.     (compiler::compile-it name definition))
  151.  
  152. (defun compile-file (input-file &key (output-file "untitled.fasl") print)
  153.     "Usage: (COMPILE-FILE input-filename :OUTPUT-FILE output-filename)"
  154.     (require :compiler)
  155.     (pl:editor-message (format nil "Compiling file ~Aﾉ" input-file))
  156.     (compiler::compile-the-file input-file output-file print))
  157.  
  158. (defun compile-without-assembling (name &optional definition)
  159.     "Usage: (COMPILE-WITHOUT-ASSEMBLING function-name &optional lambda)"
  160.     (require :compiler)
  161.     (compiler::compile-without-assembling-it name definition))
  162.  
  163. ;
  164. ;    Common Lisp 'prog1' macro
  165. ;
  166. (defmacro prog1 (first-x &rest rest-x) 
  167.     `(let* ((a1 ,first-x)) 
  168.         ,@rest-x
  169.         a1))
  170.  
  171. ;
  172. ;    Common Lisp 'prog2' macro
  173. ;
  174. (defmacro prog2 (first-x second-x &rest rest-x) 
  175.     `(let* ((a1 ,first-x) (a2 ,second-x)) 
  176.         ,@rest-x
  177.         a2))
  178.  
  179. ;
  180. ;    Simple version of LOOP macro
  181. ;
  182. (defmacro loop (&rest forms)
  183.     (dolist (f forms)
  184.         (if (symbolp f)        ;; need expanded macro    
  185.             (progn
  186.                 (require :loop)
  187.                 (return-from loop `(loop ,@forms)))))
  188.     (let ((sym (gensym)))
  189.         `(block nil (tagbody ,sym ,@forms (go ,sym)))))
  190.  
  191. ;
  192. ;    Common Lisp 'assert' macro
  193. ;
  194. (defmacro assert (x) 
  195.     `(if (null ,x) (error "Assertion failed")))
  196.  
  197. ;
  198. ;    Common Lisp 'warn' function.
  199. ;    This should really go to error-output stream.
  200. ;
  201. (defun warn (format-string &rest args)
  202.     (format t "~%Warning: ")
  203.     (apply #'format t format-string args)
  204.     (format t "~%"))
  205.  
  206. ;
  207. ;    Common Lisp 'require' function.
  208. ;    The path-name option is not implemented yet.
  209. ;
  210. (defun require (module-name &optional path-name)
  211.     (if path-name
  212.         (progn
  213.             (format t "require: path-name option not implemented~%")
  214.             (format t "Searching default directory: ~A~%"
  215.                 *library-directory*)))
  216.                 
  217.     (if (symbolp module-name)
  218.         (setq module-name (symbol-name module-name)))
  219.  
  220.     ;; load the module if necessary
  221.     (if (not (member module-name *modules* :test #'equal))
  222.         (let ((filename (concatenate 'string *library-directory* 
  223.                     module-name *lisp-file-extension*))
  224.               (compiled-filename (concatenate 'string *library-directory* 
  225.                       module-name *lisp-compiled-file-extension*)))
  226.             (cond
  227.                 ((probe-file compiled-filename)
  228.                  (load compiled-filename))
  229.                 ((probe-file filename)
  230.                  (load filename))
  231.                 (t (error "Can't locate the required module: ~A~%" module-name)))))
  232.  
  233.     ;; if it still doesn't exist, signal an error
  234.     (if (not (member module-name *modules* :test #'equal))
  235.         (error "Could not provide the required module: ~A~%" module-name))
  236.     
  237.     module-name)
  238.  
  239. ;
  240. ;    Common Lisp 'provide' function.
  241. ;
  242. (defun provide (module-name)
  243.     (if (symbolp module-name)
  244.         (setq module-name (symbol-name module-name)))
  245.     (push module-name *modules*)
  246.     module-name)
  247.  
  248. (defun %once-only-forms (form)
  249.     (let* 
  250.         ((args (rest form)) ; raw form arguments
  251.          (letlist 
  252.             (let ((newlist nil))
  253.                 (dolist (x form)
  254.                     (when (consp x) 
  255.                         (push `(,(gensym) ,x) newlist)))
  256.                 (nreverse newlist)))
  257.          (revlist 
  258.             (let ((newlist nil))
  259.                 (dolist (x letlist)
  260.                     (push (cons (second x) (first x)) newlist))
  261.                 (nreverse newlist)))
  262.          (newform (cons (first form) (sublis revlist args))))
  263.         (cons letlist newform)))
  264.  
  265. (defmacro incf (form &optional (delta 1))
  266.     (if (and (consp form) (some #'consp form))
  267.         (let ((retval (%once-only-forms form)))
  268.             `(let ,(car retval) 
  269.                 (setf ,(cdr retval) (+ ,(cdr retval) ,delta))))
  270.         `(setf ,form (+ ,form ,delta))))
  271.  
  272. (defmacro decf (form &optional (delta 1))
  273.     (if (and (consp form) (some #'consp form))
  274.         (let ((retval (%once-only-forms form)))
  275.             `(let ,(car retval) 
  276.                 (setf ,(cdr retval) (- ,(cdr retval) ,delta))))
  277.         `(setf ,form (- ,form ,delta))))
  278.  
  279. (defmacro rotatef (&rest forms)
  280.     (let ((letlist nil)
  281.           (new-forms nil)
  282.           (setf-forms nil)
  283.           (first-result nil)
  284.           (p nil))
  285.         (dolist (form forms)
  286.             (if (and (consp form) (some #'consp form))
  287.                 (let ((retval (lisp::%once-only-forms form)))
  288.                     (push (caar retval) letlist)
  289.                     (push (cdr retval) new-forms))
  290.                 (progn
  291.                     (push `(,(gensym) ,form) letlist)
  292.                     (push form new-forms))))
  293.         (setq letlist (reverse letlist))
  294.         (setq  new-forms (reverse new-forms))
  295.         (setq first-result (caar letlist))
  296.         (setq p (cdr letlist))
  297.         (dolist (form new-forms)
  298.             (push `(setf ,form ,(if p (caar p) first-result)) setf-forms)
  299.             (setf p (cdr p)))
  300.         `(let ,letlist ,@(reverse setf-forms))))
  301.  
  302. (defmacro push (val form)
  303.     (if (and (consp form) (some #'consp form))
  304.         (let ((retval (%once-only-forms form)))
  305.             `(let ,(car retval) 
  306.                 (setf ,(cdr retval) (cons ,val ,(cdr retval)))))
  307.         `(setf ,form (cons ,val ,form))))
  308.  
  309. (defmacro pop (form)
  310.     (if (and (consp form) (some #'consp form))
  311.         (let ((retval (%once-only-forms form)))
  312.             `(let ,(car retval) 
  313.                 (prog1 (first ,(cdr retval))
  314.                     (setf ,(cdr retval) (rest ,(cdr retval))))))
  315.         `(prog1 (first ,form) (setf ,form (rest ,form)))))
  316.  
  317. (defmacro pushnew (val form &rest rest)
  318.     (if (and (consp form) (some #'consp form))
  319.         (let ((retval (%once-only-forms form)))
  320.             `(let ,(car retval) 
  321.                 (setf ,(cdr retval) (adjoin ,val ,(cdr retval) ,@rest))))
  322.         `(setf ,form (adjoin ,val ,form ,@rest))))
  323.  
  324.  
  325. ;    Common Lisp 'remf' macro
  326. ;    This currently does not completely conform to the standard because
  327. ;    subexpressions are evaluated twice.
  328. ;
  329. (defmacro remf (place indicator)
  330.     `(multiple-value-bind (plist flag) 
  331.         (%remove-property ,place ,indicator)
  332.         (setf ,place plist)
  333.         flag))
  334.  
  335. ;
  336. ;    Common Lisp 'multiple-value-list' macro
  337. ;
  338. (defmacro multiple-value-list (form)
  339.     `(multiple-value-call #'list ,form))
  340.  
  341. ;
  342. ;    Common Lisp 'multiple-value-setq' macro
  343. ;
  344. (defmacro multiple-value-setq (varlist form)
  345.     (let ((setq-forms nil) 
  346.           (value-list-sym (gensym)) 
  347.           (return-form-sym (gensym)))
  348.         (do ((v varlist (cdr v)) (count 0 (1+ count)))
  349.             ((null v))
  350.             (push 
  351.                 `(setq ,(car v) (nth ,count ,value-list-sym)) 
  352.                 setq-forms))
  353.         `(let* ((,value-list-sym (multiple-value-list ,form))
  354.                 (,return-form-sym (car ,value-list-sym)))
  355.             ,@(reverse setq-forms)
  356.             ,return-form-sym)))
  357.  
  358. ;
  359. ;    Common Lisp 'multiple-value-bind' macro
  360. ;
  361. (defmacro multiple-value-bind (vars value-form &rest forms)
  362.     (let ((sym (gensym)))
  363.         `(let ,vars 
  364.             (multiple-value-setq ,vars ,value-form)
  365.             ,@forms)))
  366.  
  367. (defmacro psetq (&rest args)
  368.     (let ((syms nil) 
  369.           (values nil) 
  370.           (newsym (gensym)))
  371.         (prog* ((a args) (index 0))
  372.             loop-label
  373.             (if (null a) (return))
  374.             (if (not (symbolp (car a)))
  375.                 (error "Not a symbol: ~A" (car a)))
  376.             (if (not (consp (cdr a)))
  377.                 (error "symbol ~A without value in psetq form" (car a)))
  378.             (push `(setq ,(car a) (nth ,index ,newsym)) syms)
  379.             (push (cadr a) values)
  380.             (setq a (cddr a))
  381.             (setq index (1+ index))
  382.             (go loop-label))
  383.         (setq syms (nreverse syms))
  384.         (setq values (nreverse values))
  385.         `(let ((,newsym (list ,@values)))
  386.             (progn ,@syms) nil)))
  387.  
  388. (defmacro do* (varlist return-clause &rest body)
  389.     (let ((local-vars nil)
  390.           (inc-expressions nil)
  391.           (label (gensym)))
  392.  
  393.         ;; collect variable and increment expressions
  394.         (prog* ((v varlist) sym)
  395.             loop-label
  396.             (if (null v) (return))
  397.             (setq sym (car v))
  398.             (if (consp sym)
  399.                 (if (consp (cdr sym))
  400.                         (progn
  401.                             (push (list (car sym) (cadr sym)) local-vars)
  402.                             (if (consp (cddr sym))
  403.                                 (progn
  404.                                     (push (car sym) inc-expressions)
  405.                                     (push (caddr sym) inc-expressions))))
  406.                     (push (car sym) local-vars))
  407.                 (if (not (symbolp sym))
  408.                     (error "Improper 'do*' expression--should be a symbol: ~A" sym)
  409.                     (push sym local-vars)))
  410.             (setq v (cdr v))
  411.             (go loop-label))
  412.  
  413.         (setq local-vars (nreverse local-vars))
  414.         (setq inc-expressions `(setq ,@(nreverse inc-expressions)))
  415.         (if (not (consp return-clause))
  416.             (error "Invalid return clause in 'do*' expression: ~A" 
  417.                 return-clause))
  418.         (setq return-clause 
  419.             `(if ,(car return-clause) (return (progn ,@(cdr return-clause)))))
  420.  
  421.         `(prog* ,local-vars
  422.                ,label
  423.                ,return-clause
  424.                ,@body
  425.                ,inc-expressions
  426.                (go ,label))))
  427.  
  428. (defmacro do (varlist return-clause &rest body)
  429.     (let ((local-vars nil)
  430.           (inc-expressions nil)
  431.           (label (gensym)))
  432.  
  433.         ;; collect variable and increment expressions
  434.         (prog* ((v varlist) sym)
  435.             loop-label
  436.             (if (null v) (return))
  437.             (setq sym (car v))
  438.             (if (consp sym)
  439.                 (if (consp (cdr sym))
  440.                         (progn
  441.                             (push (list (car sym) (cadr sym)) local-vars)
  442.                             (if (consp (cddr sym))
  443.                                 (progn
  444.                                     (push (car sym) inc-expressions)
  445.                                     (push (caddr sym) inc-expressions))))
  446.                     (push (car sym) local-vars))
  447.                 (if (not (symbolp sym))
  448.                     (error "Improper 'do' expression--should be a symbol: ~A" sym)
  449.                     (push sym local-vars)))
  450.             (setq v (cdr v))
  451.             (go loop-label))
  452.  
  453.         (setq local-vars (nreverse local-vars))
  454.         (setq inc-expressions `(psetq ,@(nreverse inc-expressions)))
  455.         (if (not (consp return-clause))
  456.             (error "Invalid return clause in 'do' expression: ~A" 
  457.                 return-clause))
  458.         (setq return-clause 
  459.             `(if ,(car return-clause) (return (progn ,@(cdr return-clause)))))
  460.  
  461.         `(prog ,local-vars
  462.                ,label
  463.                ,return-clause
  464.                ,@body
  465.                ,inc-expressions
  466.                (go ,label))))
  467.  
  468. ;
  469. ;    Common Lisp 'ecase' macro.
  470. ;
  471. (defmacro ecase (key &rest clauses)
  472.     `(case ,key ,@clauses (otherwise (error "No matching key found in ecase form."))))
  473.  
  474. ;
  475. ;    Set up the reader macro which allows for #| ... |# type comments
  476. ;
  477. (set-dispatch-macro-character #¥# #¥| 
  478.     #'(lambda (stream char int)
  479.             (do ((c (read-char stream) (read-char stream)))
  480.                  ((and (char= c #¥|) (char= (peek-char nil stream) #¥#))
  481.                          (read-char stream)(values)) nil)))
  482.  
  483. ;
  484. ;    Set up the reader macro which allows for #+ and #- conditional reads
  485. ;
  486. (defun %features-member (feature-list)
  487.     (if (symbolp feature-list)
  488.         (return (member feature-list *features*)))
  489.     (if (consp feature-list)
  490.         (ecase (car feature-list)
  491.             (and (every #'%features-member (cdr feature-list)))
  492.             (or  (some #'%features-member (cdr feature-list)))    
  493.             (not (notany #'%features-member (cdr feature-list))))
  494.         (error "~A is not a valid feature." feature-list)))
  495.  
  496.  
  497. (set-dispatch-macro-character #¥# #¥+ 
  498.     #'(lambda (stream char int)
  499.         (let ((feature (read stream)))
  500.             (if (%features-member feature)
  501.                 (return (read stream)))
  502.  
  503.             ; else need to skip over the next expression
  504.             (let ((*read-suppress* t))
  505.                 (read stream))
  506.             (return (values)))))
  507.  
  508. (set-dispatch-macro-character #¥# #¥- 
  509.     #'(lambda (stream char int)
  510.         (let ((feature (read stream)))
  511.             (if (not (%features-member feature))
  512.                 (return (read stream)))
  513.  
  514.             ; else need to skip over the next expression
  515.             (let ((*read-suppress* t))
  516.                 (read stream))
  517.             (return (values)))))
  518.  
  519. ;
  520. ;    Reader macro which handles #. syntax.
  521. ;
  522. (set-dispatch-macro-character #¥# #¥. 
  523.     #'(lambda (stream char int)
  524.         (eval (read stream))))
  525.  
  526. ;
  527. ;    Set up reader macro for octal, binary and hex numbers
  528. ;    #onnn -> octal, #bnnn ->binary, #xnnn ->hex
  529. ;
  530. (set-dispatch-macro-character #¥# #¥O 
  531.     #'(lambda (stream char int)
  532.         (let ((*read-base* 8)) 
  533.             (read stream))))
  534.  
  535. (set-dispatch-macro-character #¥# #¥B 
  536.     #'(lambda (stream char int)
  537.         (let ((*read-base* 2)) 
  538.             (read stream))))
  539.  
  540. (set-dispatch-macro-character #¥# #¥X 
  541.     #'(lambda (stream char int)
  542.         (let ((*read-base* 16))
  543.             (read stream))))
  544.  
  545. (set-dispatch-macro-character #¥# #¥R 
  546.     #'(lambda (stream char int)
  547.         (let ((*read-base* int))
  548.             (read stream))))
  549.  
  550. ;
  551. ;    SETF expansion functions
  552. ;
  553. (defmacro defsetf (sym func)
  554.     `(putprop ',sym 'cl::_setf_expansion_ ',func))
  555.  
  556. (defsetf symbol-value %set-symbol-value)
  557. (defsetf symbol-function %set-symbol-function)
  558. (defsetf symbol-plist %set-symbol-plist)
  559. (defsetf macro-function %set-macro-function)
  560. (defsetf documentation put-documentation)
  561. (defsetf char common-lisp::%setchar)
  562. (defsetf schar common-lisp::%setchar)
  563. (defun %setcar (v c) (rplaca c v) v)
  564. (defsetf car %setcar)
  565. (defun %setcdr (v c) (rplacd c v) v)
  566. (defsetf cdr %setcdr)
  567. (defsetf rest %setcdr)
  568. (defun %setcaar (v x) (setf (car (car x)) v))
  569. (defsetf caar %setcaar)
  570. (defun %setcadr (v x) (setf (car (cdr x)) v))
  571. (defsetf cadr %setcadr)
  572. (defun %setcdar (v x) (setf (cdr (car x)) v))
  573. (defsetf cdar %setcdar)
  574. (defun %setcddr (v x) (setf (cdr (cdr x)) v))
  575. (defsetf cddr %setcddr)
  576. (defsetf elt setelt)
  577. (defsetf aref _set-aref)
  578. (defun svref (vec index) (elt vec index))
  579. (defun _setsvref (v vec index) (setelt v vec index))
  580. (defsetf svref _setsvref)
  581. (defun %set-get (v sym prop) (putprop sym prop v) v)
  582. (defsetf get %set-get)
  583. (defsetf gethash addhash)
  584. (defsetf fill-pointer _set_fill_pointer)
  585. (defun %setfirst (v s) (setelt v s 0))
  586. (defsetf first %setfirst)
  587. (defun %setsecond (v s) (setelt v s 1))
  588. (defsetf second %setsecond)
  589. (defun %setthird (v s) (setelt v s 2))
  590. (defsetf third %setthird)
  591. (defun %setfourth (v s) (setelt v s 3))
  592. (defsetf fourth %setfourth)
  593. (defun %setfifth (v s) (setelt v s 4))
  594. (defsetf fifth %setfifth)
  595. (defun %setsixth (v s) (setelt v s 5))
  596. (defsetf sixth %setsixth)
  597. (defun %setseventh (v s) (setelt v s 6))
  598. (defsetf seventh %setseventh)
  599. (defun %seteighth (v s) (setelt v s 7))
  600. (defsetf eighth %seteighth)
  601. (defun %setninth (v s) (setelt v s 8))
  602. (defsetf ninth %setninth)
  603. (defun %settenth (v s) (setelt v s 9))
  604. (defsetf tenth %settenth)
  605. ;
  606. ;    constants for Common Lisp
  607. (defconstant array-rank-limit 8)
  608. (defconstant array-dimension-limit 2147483647)
  609. (defconstant array-total-size-limit 2147483647) 
  610. (defconstant internal-time-units-per-second 1000000)
  611. (defconstant pi 3.14159265358979323846)
  612.  
  613. (defvar *load-verbose* nil) 
  614. (defvar *load-print* nil)
  615. (defvar *error-output* *terminal-io*)
  616. (defvar *query-io* *terminal-io*)
  617.  
  618. (defun %is-binary (input-stream)
  619.     (let ((x (read-byte input-stream)))
  620.         (file-position input-stream 0)
  621.         (return (= x 0))))
  622.         
  623. (defun load (filename 
  624.         &key (verbose *load-verbose*) 
  625.              (print *load-print*) 
  626.              if-does-not-exist)
  627.     (let*
  628.         ((loaded 0)
  629.          (stream nil)
  630.          (binary nil)
  631.          (message (format nil "Loading file ~Aﾉ" filename))
  632.          (*package* *package*)            ;; bind these to themselves
  633.          (*readtable* *readtable*)
  634.          (*standard-output* *standard-output*))
  635.          
  636.         (if (symbolp filename)
  637.             (setq filename (symbol-name filename)))
  638.         (if (streamp filename)
  639.             (setq stream filename)
  640.             (if (not (stringp filename))
  641.                 (error "Invalid file name")))
  642.         
  643.         (unless stream (setq stream (open filename :direction :input)))
  644.         (setq binary (%is-binary stream))
  645.  
  646.         (if binary 
  647.             (progn
  648.                 (if verbose
  649.                     (progn
  650.                         (format t ";;~%")
  651.                         (format t ";; Loading compiled file: ~A~%" filename)
  652.                         (format t ";;~%")))
  653.         
  654.                 (do* ((expr t) (symbol-table (make-array 500)))
  655.                     ((null expr)(close stream)(return-from load loaded))
  656.                     (pl:editor-message message)
  657.                     (setq expr (%read-code-from-stream stream symbol-table))
  658.                     (if expr
  659.                         (let ((result (funcall expr)))
  660.                             (if print (print result))
  661.                             (incf loaded))))))
  662.  
  663.         (if verbose
  664.             (progn
  665.                 (format t ";;~%")
  666.                 (format t ";; Loading file: ~A~%" filename)
  667.                 (format t ";;~%")))
  668.         
  669.         (do* ((expr nil))
  670.             ((eq expr 'Eof)(close stream)(return-from load loaded))
  671.             (pl:editor-message message)
  672.             (setq expr (read stream nil 'Eof nil))
  673.             (if (not (eq expr 'Eof))
  674.                 (progn
  675.                     (setq expr (eval expr))
  676.                     (if print (print expr))
  677.                     (incf loaded))))))
  678.  
  679. ;;
  680. ;;    Common Lisp 'defun' macro.
  681. ;;    This redefines the built-in special form.
  682. ;;
  683. (defmacro defun (name lambda-list &rest forms)
  684.     (let ((doc-form nil) 
  685.           (lambda-form nil) 
  686.           (declarations nil))
  687.  
  688.         ;; look for declarations and doc string
  689.         (do* ((f forms (cdr f)))
  690.             ((null f) (setq forms f))
  691.             (if (and (typep (car f) 'string) (null doc-form) (cdr f))
  692.                 (setq doc-form 
  693.                     `((setf (documentation ',name 'function) ,(car f))))
  694.                 (if (and (consp (car f)) (eq (caar f) 'declare))
  695.                     (push (car f) declarations)
  696.                     (progn (setq forms f) (return)))))
  697.  
  698.         (setq lambda-form 
  699.             `(lambda ,lambda-list ,@(nreverse declarations)
  700.                 (block ,name ,@forms)))         
  701.         `(progn
  702.             ,@doc-form
  703.             (setf (symbol-function ',name) (function ,lambda-form))
  704.             ',name))) 
  705.  
  706. ;;
  707. ;;    Common Lisp 'defmacro' macro.
  708. ;;    This redefines the built-in special form.
  709. ;;
  710. (defmacro defmacro (name lambda-list &rest forms)
  711.     (let ((doc-form nil) 
  712.           (lambda-form nil)
  713.           (declarations nil))
  714.  
  715.         ;; look for declarations and doc string
  716.         (do* ((f forms (cdr f)))
  717.             ((null f) (setq forms f))
  718.             (if (and (typep (car f) 'string) (null doc-form) (cdr f))
  719.                 (setq doc-form 
  720.                     `((setf (documentation ',name 'macro) ,(car f))))
  721.                 (if (and (consp (car f)) (eq (caar f) 'declare))
  722.                     (push (car f) declarations)
  723.                     (progn (setq forms f) (return)))))
  724.  
  725.         (setq lambda-form 
  726.             `(lambda (form &optional env) 
  727.                 (destructuring-bind ,lambda-list 
  728.                     (cdr form)
  729.                     ,@(nreverse declarations) 
  730.                     (block ,name ,@forms)))) 
  731.         `(progn
  732.             ,@doc-form
  733.             (setf (macro-function ',name) (function ,lambda-form))
  734.             ',name))) 
  735.             
  736. ;;
  737. ;;    Common Lisp 'deftype' macro.
  738. ;;
  739. (defmacro deftype (name lambda-list &rest forms)
  740.     (let ((doc-form nil) (lambda-form nil))
  741.         (if (and (typep (car forms) 'string) (cdr forms))
  742.             (progn
  743.                 (setq doc-form 
  744.                     `((setf (documentation ',name 'type) ,(car forms))))
  745.                 (setq forms (cdr forms))))
  746.  
  747.         (setq lambda-form 
  748.             `(lambda (form &optional env) 
  749.                 (type-destructuring-bind ,lambda-list 
  750.                     (cdr form) 
  751.                     (block ,name ,@forms)))) 
  752.         `(progn
  753.             ,@doc-form
  754.             (setf (get ',name '_type_expansion_) (function ,lambda-form))
  755.             (null-environment (get ',name '_type_expansion_))
  756.             ',name))) 
  757.  
  758. ;
  759. ;    Common Lisp 'defstruct' macro.
  760. ;
  761. (defmacro defstruct (name-and-options &rest doc-and-slots)
  762.     (require :structures)        ;; load module
  763.     `(defstruct ,name-and-options ,@doc-and-slots))
  764.  
  765. ;
  766. ;    CLOS macros
  767. (defmacro defclass (&rest args)
  768.     (require :clos)        ;; load module
  769.     `(defclass ,@args))
  770.  
  771. (defmacro defgeneric (&rest args)
  772.     (require :clos)        ;; load module
  773.     `(defgeneric ,@args))
  774.  
  775. (defmacro defmethod (&rest args)
  776.     (require :clos)        ;; load module
  777.     `(defmethod ,@args))
  778.  
  779. ;
  780. ;    Common Lisp 'defpackage' macro.
  781. ;
  782. (defmacro defpackage (name &rest options)
  783.     (require :defpackage)        ;; load module
  784.     `(defpackage ,name ,@options))
  785.  
  786. ;
  787. ;    Common Lisp 'in-package' macro
  788. ;
  789. (defmacro in-package (name)
  790.     `(eval-when (:load-toplevel :compile-toplevel :execute)
  791.         (let ((package (find-package ,name)))
  792.             (if package
  793.                 (setq *package* package)
  794.                 (setq *package* (make-package ,name))))))
  795.  
  796. ;
  797. ;    Common Lisp 'time' macro.
  798. ;
  799. ;
  800. (defmacro time (x)
  801.     `(let ((tm (get-internal-run-time)) ret)
  802.         (setq ret ,x)
  803.         (setq tm (- (get-internal-run-time) tm))
  804.         (decf tm (%elapsed-time nil))    ;; subtract timer overhead
  805.         (setq tm (/ (float tm) 1000000.0))
  806.         (format *trace-output* "Execution time: ~A seconds~%" tm)
  807.         ret))        
  808.  
  809. ; This private macro '%elapsed-time' acts like time, but returns the
  810. ; time elapsed after evaluating the passed expression.
  811. ;
  812. (defmacro %elapsed-time (x)
  813.     `(let ((tm (get-internal-run-time)) ret)
  814.         (setq ret ,x)
  815.         (setq tm (- (get-internal-run-time) tm))
  816.         tm))        
  817.         
  818. ;;;    Some standard predicates
  819. (defun functionp (x)     (typep x 'function))
  820. (defun keywordp (x)     (typep x 'keyword))
  821. (defun arrayp (x)         (typep x 'array))
  822. (defun packagep (x)     (typep x 'package))
  823. (defun bit-vector-p (x) (typep x 'bit-vector))
  824.  
  825. ;
  826. ;    Common Lisp 'string' function.
  827. ;
  828. (defun string (x)
  829.     (cond 
  830.         ((stringp x) x)
  831.         ((symbolp x) (symbol-name x))
  832.         ((characterp x)
  833.          (let ((string " ")) (setf (elt string 0) x) string))))
  834.  
  835. ;
  836. ;    Common Lisp 'position' function.
  837. ;
  838. (defun position (item sequence 
  839.         &key from-end (test #'eql) test-not (start 0) end key)
  840.     (unless (typep sequence 'sequence) 
  841.         (error "Not a sequence: ~A" sequence))
  842.     (unless (integerp end) 
  843.         (setq end (length sequence)))
  844.     (if test-not (setq test #'(lambda (x y) (not (funcall test-not x y)))))
  845.  
  846.     (if from-end
  847.         ;; loop backward
  848.         (do ((i (1- end) (- i 1))
  849.              (x))
  850.             ((< i start) nil)
  851.             (setq x (elt sequence i))
  852.             (if key (setq x (funcall key x)))
  853.             (if (funcall test item x)
  854.                 (return i)))
  855.  
  856.         ;;; else go forward
  857.         (do ((i start (+ i 1))
  858.              (x))
  859.             ((>= i end) nil)
  860.             (setq x (elt sequence i))
  861.             (if key (setq x (funcall key x)))
  862.             (if (funcall test item x)
  863.                 (return i)))))
  864.  
  865. ;
  866. ;    Common Lisp 'position-if' function.
  867. ;
  868. (defun position-if (test sequence 
  869.         &key from-end (start 0) end key)
  870.     (unless (typep sequence 'sequence) 
  871.         (error "Not a sequence: ~A" sequence))
  872.     (unless (functionp test) 
  873.         (error "Not a function: ~A" test))
  874.     (unless (integerp end) 
  875.         (setq end (length sequence)))
  876.  
  877.     (if from-end
  878.         ;; loop backward
  879.         (do ((i (1- end) (- i 1))
  880.              (x))
  881.             ((< i start) nil)
  882.             (setq x (elt sequence i))
  883.             (if key (setq x (funcall key x)))
  884.             (if (funcall test x)
  885.                 (return i)))
  886.  
  887.         ;;; else go forward
  888.         (do ((i start (+ i 1))
  889.              (x))
  890.             ((>= i end) nil)
  891.             (setq x (elt sequence i))
  892.             (if key (setq x (funcall key x)))
  893.             (if (funcall test x)
  894.                 (return i)))))
  895.  
  896. ;
  897. ;    Common Lisp 'position-if-not' function.
  898. ;
  899. (defun position-if-not (test sequence 
  900.         &key from-end (start 0) end key)
  901.     (unless (typep sequence 'sequence) 
  902.         (error "Not a sequence: ~A" sequence))
  903.     (unless (functionp test) 
  904.         (error "Not a function: ~A" test))
  905.     (unless (integerp end) 
  906.         (setq end (length sequence)))
  907.  
  908.     (if from-end
  909.         ;; loop backward
  910.         (do ((i (1- end) (- i 1))
  911.              (x))
  912.             ((< i start) nil)
  913.             (setq x (elt sequence i))
  914.             (if key (setq x (funcall key x)))
  915.             (if (not (funcall test x))
  916.                 (return i)))
  917.  
  918.         ;;; else go forward
  919.         (do ((i start (+ i 1))
  920.              (x))
  921.             ((>= i end) nil)
  922.             (setq x (elt sequence i))
  923.             (if key (setq x (funcall key x)))
  924.             (if (not (funcall test x))
  925.                 (return i)))))
  926.  
  927. ;
  928. ;    Common Lisp 'find' function.
  929. ;
  930. (defun find (item sequence 
  931.         &key from-end (test #'eql) test-not (start 0) end key)
  932.     (unless (typep sequence 'sequence) 
  933.         (error "Not a sequence: ~A" sequence))
  934.     (unless (integerp end) 
  935.         (setq end (length sequence)))
  936.     (if test-not (setq test #'(lambda (x y) (not (funcall test-not x y)))))
  937.  
  938.     (if from-end
  939.         ;; loop backward
  940.         (do ((i (1- end) (- i 1)) 
  941.              (x))
  942.             ((< i start) nil)
  943.             (setq x (elt sequence i))
  944.             (if (funcall test item (if key (funcall key x) x))
  945.                 (return x)))
  946.  
  947.         ;;; else go forward
  948.         (do ((i start (+ i 1)) 
  949.              (x))
  950.             ((>= i end) nil)
  951.             (setq x (elt sequence i))
  952.             (if (funcall test item (if key (funcall key x) x))
  953.                 (return x)))))
  954.  
  955. ;
  956. ;    Common Lisp 'find-if' function.
  957. ;
  958. (defun find-if (test sequence 
  959.         &key from-end (start 0) end key)
  960.     (unless (typep sequence 'sequence) 
  961.         (error "Not a sequence: ~A" sequence))
  962.     (unless (functionp test) 
  963.         (error "Not a function: ~A" test))
  964.     (unless (integerp end) 
  965.         (setq end (length sequence)))
  966.  
  967.     (if from-end
  968.         ;; loop backward
  969.         (do ((i (1- end) (- i 1)) 
  970.              (x))
  971.             ((< i start) nil)
  972.             (setq x (elt sequence i))
  973.             (if (funcall test (if key (funcall key x) x))
  974.                 (return x)))
  975.  
  976.         ;;; else go forward
  977.         (do ((i start (+ i 1)) 
  978.              (x))
  979.             ((>= i end) nil)
  980.             (setq x (elt sequence i))
  981.             (if (funcall test (if key (funcall key x) x))
  982.                 (return x)))))
  983.  
  984. ;
  985. ;    Common Lisp 'find-if-not' function.
  986. ;
  987. (defun find-if-not (test sequence 
  988.         &key from-end (start 0) end key)
  989.     (unless (typep sequence 'sequence) 
  990.         (error "Not a sequence: ~A" sequence))
  991.     (unless (functionp test) 
  992.         (error "Not a function: ~A" test))
  993.     (unless (integerp end) 
  994.         (setq end (length sequence)))
  995.  
  996.     (if from-end
  997.         ;; loop backward
  998.         (do ((i (1- end) (- i 1)) 
  999.              (x))
  1000.             ((< i start) nil)
  1001.             (setq x (elt sequence i))
  1002.             (if (not (funcall test (if key (funcall key x) x)))
  1003.                 (return x)))
  1004.  
  1005.         ;;; else go forward
  1006.         (do ((i start (+ i 1)) 
  1007.              (x))
  1008.             ((>= i end) nil)
  1009.             (setq x (elt sequence i))
  1010.             (if (not (funcall test (if key (funcall key x) x)))
  1011.                 (return x)))))
  1012.  
  1013. ;
  1014. ;    Common Lisp 'count' function.
  1015. ;
  1016. (defun count (item sequence 
  1017.         &key from-end (test #'eql) test-not (start 0) end key)
  1018.     (unless (typep sequence 'sequence) 
  1019.         (error "Not a sequence: ~A" sequence))
  1020.     (unless (integerp end) 
  1021.         (setq end (length sequence)))
  1022.     (if test-not (setq test #'(lambda (x y) (not (funcall test-not x y)))))
  1023.  
  1024.     ;; we can ignore the :from-end key
  1025.     (if key
  1026.         (do ((i start (+ i 1))
  1027.               (count 0))
  1028.             ((>= i end) count)
  1029.             (if (funcall test (funcall key (elt sequence i)) item)
  1030.                 (incf count)))
  1031.         ;; else
  1032.         (do ((i start (+ i 1))
  1033.               (count 0))
  1034.             ((>= i end) count)
  1035.             (if (funcall test (elt sequence i) item)
  1036.                 (incf count)))))
  1037.  
  1038. ;
  1039. ;    Common Lisp 'count-if' function.
  1040. ;
  1041. (defun count-if (test sequence 
  1042.         &key from-end (start 0) end key)
  1043.     (unless (typep sequence 'sequence) 
  1044.         (error "Not a sequence: ~A" sequence))
  1045.     (unless (functionp test) 
  1046.         (error "Not a function: ~A" test))
  1047.     (unless (integerp end) 
  1048.         (setq end (length sequence)))
  1049.  
  1050.     ;; we can ignore the :from-end key
  1051.     (if key
  1052.         (do ((i start (+ i 1))
  1053.               (count 0))
  1054.             ((>= i end) count)
  1055.             (if (funcall test (funcall key (elt sequence i)))
  1056.                 (incf count)))
  1057.         ;; else
  1058.         (do ((i start (+ i 1))
  1059.               (count 0))
  1060.             ((>= i end) count)
  1061.             (if (funcall test (elt sequence i))
  1062.                 (incf count)))))
  1063.  
  1064. ;
  1065. ;    Common Lisp 'count-if-not' function.
  1066. ;
  1067. (defun count-if-not (test sequence 
  1068.         &key from-end (start 0) end key)
  1069.     (unless (typep sequence 'sequence) 
  1070.         (error "Not a sequence: ~A" sequence))
  1071.     (unless (functionp test) 
  1072.         (error "Not a function: ~A" test))
  1073.     (unless (integerp end) 
  1074.         (setq end (length sequence)))
  1075.  
  1076.     ;; we can ignore the :from-end key
  1077.     (if key
  1078.         (do ((i start (+ i 1))
  1079.               (count 0))
  1080.             ((>= i end) count)
  1081.             (if (not (funcall test (funcall key (elt sequence i))))
  1082.                 (incf count)))
  1083.         ;; else
  1084.         (do ((i start (+ i 1))
  1085.               (count 0))
  1086.             ((>= i end) count)
  1087.             (if (not (funcall test (elt sequence i)))
  1088.                 (incf count)))))
  1089.  
  1090. ;
  1091. ;    Common Lisp 'fill' function.
  1092. ;
  1093. (defun fill (sequence item &key (start 0) end)
  1094.     (unless (typep sequence 'sequence) 
  1095.         (error "Not a sequence: ~A" sequence))
  1096.     (unless (integerp end) 
  1097.         (setq end (length sequence)))
  1098.     (dotimes (i (- end start))
  1099.         (setf (elt sequence (+ i start)) item))
  1100.     sequence)
  1101.  
  1102. ;
  1103. ;    Common Lisp 'replace' function.
  1104. ;
  1105. (defun replace (sequence1 sequence2 &key (start1 0) end1 (start2 0) end2)
  1106.     (unless (typep sequence1 'sequence) 
  1107.         (error "Not a sequence: ~A" sequence1))
  1108.     (unless (typep sequence2 'sequence) 
  1109.         (error "Not a sequence: ~A" sequence2))
  1110.     (unless (integerp end1) 
  1111.         (setq end1 (length sequence1)))
  1112.     (unless (integerp end2) 
  1113.         (setq end2 (length sequence2)))
  1114.     (dotimes (i (min (- end1 start1) (- end2 start2)))
  1115.         (setf (elt sequence1 (+ i start1)) (elt sequence2 (+ i start2))))
  1116.     sequence1)
  1117.  
  1118. ;
  1119. ;    Common Lisp 'mismatch' function.
  1120. ;
  1121. (defun mismatch (sequence1 sequence2 
  1122.         &key (from-end nil)
  1123.              (test #'eql) 
  1124.              (test-not nil)
  1125.              (key nil)
  1126.              (start1 0) 
  1127.              (start2 0)
  1128.              (end1 (length sequence1))
  1129.              (end2 (length sequence2)))
  1130.  
  1131.     (unless (typep sequence1 'sequence)
  1132.         (error "Not a sequence: ~A" sequence1))
  1133.     (unless (typep sequence2 'sequence)
  1134.         (error "Not a sequence: ~A" sequence2))
  1135.     (if test-not (setq test #'(lambda (x y) (not (funcall test-not x y)))))
  1136.  
  1137.     (if from-end
  1138.         ;; loop backward
  1139.         (do* ((i1 start1 (1+ i1))
  1140.               (i2 start2 (1+ i2)) 
  1141.               x1 x2)
  1142.             ((and (>= i1 end1) (>= i2 end2)) nil)
  1143.             (if (>= i1 end1) (return i1))
  1144.             (if (>= i2 end2) (return i1))
  1145.             (setq x1 (elt sequence1 i1))
  1146.             (setq x2 (elt sequence2 i2))
  1147.             (if key 
  1148.                 (progn
  1149.                     (setq x1 (funcall key x1))
  1150.                     (setq x2 (funcall key x2))))
  1151.             (unless (funcall test x1 x2)
  1152.                 (return i1)))
  1153.  
  1154.         ;;; else go forward
  1155.         (do* ((i1 start1 (1+ i1))
  1156.               (i2 start2 (1+ i2))
  1157.               x1 x2)
  1158.             ((and (>= i1 end1) (>= i2 end2)) nil)
  1159.             (if (>= i1 end1) (return i1))
  1160.             (if (>= i2 end2) (return i1))
  1161.             (setq x1 (elt sequence1 i1))
  1162.             (setq x2 (elt sequence2 i2))
  1163.             (if key
  1164.                 (progn
  1165.                     (setq x1 (funcall key x1))
  1166.                     (setq x2 (funcall key x2))))
  1167.             (unless (funcall test x1 x2)
  1168.                 (return i1)))))
  1169.  
  1170. ;
  1171. ;    Common Lisp 'search' function.
  1172. ;
  1173. (defun search (sequence1 sequence2 
  1174.         &key (from-end nil)
  1175.              (test #'eql) 
  1176.              (test-not nil)
  1177.              (key nil)
  1178.              (start1 0) 
  1179.              (start2 0)
  1180.              (end1 (length sequence1))
  1181.              (end2 (length sequence2)))
  1182.  
  1183.     (unless (typep sequence1 'sequence)
  1184.         (error "Not a sequence: ~A" sequence1))
  1185.     (unless (typep sequence2 'sequence)
  1186.         (error "Not a sequence: ~A" sequence2))
  1187.     (if test-not (setq test #'(lambda (x y) (not (funcall test-not x y)))))
  1188.  
  1189.     (if from-end
  1190.         ;; loop backward
  1191.         (do* ((i (1- end2) (1- i)) 
  1192.               compare)
  1193.             ((< i start2) nil)
  1194.             (setq compare (mismatch sequence1 sequence2 :test test
  1195.                     :key key :start1 start1 :end1 end1 :start2 i))
  1196.             (if (or (null compare) (>= compare end1))
  1197.                 (return i)))
  1198.  
  1199.         ;;; else go forward
  1200.         (do* ((i start2 (1+ i)) 
  1201.               compare)
  1202.             ((>= i end2) nil)
  1203.             (setq compare (mismatch sequence1 sequence2 :test test
  1204.                     :key key :start1 start1 :end1 end1 :start2 i))
  1205.             (if (or (null compare) (>= compare end1))
  1206.                 (return i)))))
  1207.  
  1208. ;
  1209. ;    Common Lisp 'prin1' function.
  1210. ;
  1211. (defun prin1 (object &optional (output-stream *standard-output*))
  1212.     (write object :stream output-stream :escape t))
  1213.  
  1214. ;
  1215. ;    Common Lisp 'print' function.
  1216. ;
  1217. (defun print (object &optional (output-stream *standard-output*))
  1218.     (write #¥Newline :stream output-stream :escape t)
  1219.     (write object :stream output-stream :escape t)
  1220.     (write #¥Space :stream output-stream :escape t)
  1221.     object)
  1222. ;
  1223. ;    Common Lisp 'pprint' function.
  1224. ;    This is not fully implemented yet.
  1225. ;
  1226. (defun pprint (object &optional (output-stream *standard-output*))
  1227.     (write #¥Newline :stream output-stream :escape t)
  1228.     (write object :stream output-stream :escape t :pretty t)
  1229.     (values))
  1230.  
  1231. ;
  1232. ;    Common Lisp 'princ' function.
  1233. ;
  1234. (defun princ (object &optional (output-stream *standard-output*))
  1235.     (write object :stream output-stream :escape nil))
  1236.  
  1237. ;
  1238. ;    Common Lisp 'mapcan' function.
  1239. ;
  1240. (defun mapcan (func list &rest more-lists)
  1241.     (apply #'nconc (apply #'mapcar (cons func (cons list more-lists)))))
  1242.  
  1243. ;
  1244. ;    Common Lisp 'mapcon' function.
  1245. ;
  1246. (defun mapcon (func list &rest more-lists)
  1247.     (apply #'nconc (apply #'maplist (cons func (cons list more-lists)))))
  1248.  
  1249. (defun copy-alist (alist)
  1250.     (let ((newlist nil))
  1251.         (dolist (n alist)
  1252.             (push 
  1253.                 (if (consp n)
  1254.                     (cons (car n) (cdr n))
  1255.                     n)
  1256.                 newlist))
  1257.         (nreverse newlist)))
  1258.  
  1259. ;
  1260. ;    Common Lisp 'read-from-string' function.
  1261. ;    To do: handle eof-error, eof-value, preserve-whitespace settings    
  1262. ;
  1263. (defun read-from-string (string &optional eof-error eof-value 
  1264.             &key (start 0) end preserve-whitespace 
  1265.             &aux string-stream expr position)
  1266.     (if (not (typep string 'string)) (error "Not a string"))
  1267.     (if (not end) (setq end (length string)))
  1268.     (setq string-stream (make-string-input-stream string start end))
  1269.     (setq expr (read string-stream))
  1270.     (setq position (file-position string-stream))
  1271.     (if (eq position 'Eof) (setq position (- end start)))
  1272.     (values expr position))    
  1273.  
  1274. ;
  1275. ;    Common Lisp 'with-output-to-string' macro.
  1276. ;
  1277. (defmacro with-output-to-string ((var &optional string) &rest forms)
  1278.     `(let ((,var (make-string-output-stream)) (ret ,string) string)    
  1279.         (unwind-protect
  1280.             (progn
  1281.                 (let ()        ; establish a let block to allow declarations
  1282.                     ,@forms)
  1283.                 (setq string (get-output-stream-string ,var))
  1284.                 (if ret
  1285.                     (dotimes (i (length string))
  1286.                         (vector-push-extend (elt string i) ret))
  1287.                     (setq ret string)))
  1288.             (close ,var))
  1289.         ret))
  1290.  
  1291. ;;
  1292. ;;    Normal top level user input function.
  1293. ;;    This will get executed at startup and for the duration of an
  1294. ;;    interactive session.
  1295. ;;    By default, this function is the value of the variable *top-level*.
  1296. ;;
  1297.  
  1298. (defvar +)
  1299. (defvar ++)
  1300. (defvar +++)
  1301. (defvar -)
  1302. (defvar *)
  1303. (defvar **)
  1304. (defvar ***)
  1305. (defvar /)
  1306. (defvar //)
  1307. (defvar ///)
  1308. (export '(+ ++ +++ - * ** *** / // ///))
  1309. (defun top-level ()
  1310.     (do (expr result)
  1311.         (nil)
  1312.         (catch 'common-lisp::%error
  1313.             (progn
  1314.                 (setq *read-level* 0)
  1315.                 (setq expr (read *standard-input* nil 'Eof nil))
  1316. ;;                (if (eq expr 'quit)
  1317. ;;                    (return))
  1318.                 (if (eq expr 'Eof)
  1319.                     (return 'Eof))
  1320.                 (pl:editor-message "Thinkingﾉ")    ;; display status message
  1321.                 (setq - expr)
  1322.                 (setq result (multiple-value-list (eval expr)))
  1323.  
  1324.                 ;; update top level variables
  1325.                 (unless (member expr '(+++ ++ + - *** ** * /// // /))
  1326.                     (progn
  1327.                         (setq +++ ++)
  1328.                         (setq ++ +)
  1329.                         (setq + expr)
  1330.                         (setq *** **)
  1331.                         (setq ** *)
  1332.                         (setq * (if (consp result) (car result) result))
  1333.                         (setq /// //)
  1334.                         (setq // /)
  1335.                         (setq / result)))
  1336.  
  1337.                 (if result (format t "~A~{ ~A~}~%" (car result) (cdr result)))))))
  1338.  
  1339. (setq *top-level* #'common-lisp::top-level)
  1340.  
  1341. ;
  1342. ;    Common Lisp 'identity' function.
  1343. ;
  1344. (defun identity (object) object)
  1345.  
  1346. (defun finish-output (&optional (stream *standard-output*)) 
  1347.     (file-flush stream))
  1348.  
  1349. (defun force-output (&optional (stream *standard-output*)) 
  1350.     (file-flush stream))
  1351.  
  1352. (defun clear-output (&optional (stream *standard-output*)) 
  1353.     (file-flush stream))
  1354.  
  1355. (defun parse-integer (string 
  1356.         &key (start 0) 
  1357.              (end (length string))
  1358.              (radix 10)
  1359.              (junk-allowed nil)
  1360.         &aux (result 0)
  1361.              (state :initial)
  1362.              (sign 1)
  1363.              c)
  1364.  
  1365.     ;; check for leading sign
  1366.     (setf c (char string start))
  1367.     (if (char= c #¥-)
  1368.         (progn (setf sign -1) (incf start))
  1369.         (if (char= c #¥+)
  1370.             (incf start)))
  1371.  
  1372.     (do* ((i start (+ i 1))
  1373.           (n 0))
  1374.         ((>= i end))
  1375.         (setq c (char string i))
  1376.         (setq n (digit-char-p c radix))
  1377.         (cond
  1378.             (n (progn
  1379.                 (cond
  1380.                     ((eq state :finished) 
  1381.                      (if (not junk-allowed)
  1382.                         (error "Invalid integer parsed: ~A" string)
  1383.                         (progn (setq end i) (return)))))
  1384.                 (setq result (+ (* result radix) n))
  1385.                 (setq state :collecting)))
  1386.             
  1387.             ((member c '(#¥Newline #¥Space #¥Tab))
  1388.                 (cond
  1389.                     ((eq state :collecting) (setq state :finished))
  1390.                     ((eq state :initial) nil)    ; don't do anything
  1391.                     ((eq state :finished) nil)))
  1392.             (t 
  1393.                 (if (not junk-allowed)
  1394.                     (error "Invalid integer parsed: ~A" string)
  1395.                     (progn (setq end i) (return))))))
  1396.  
  1397.     (if (eq state :initial)
  1398.         (setq result nil)
  1399.         (setq result (* result sign)))
  1400.     (values result end))
  1401.  
  1402.  
  1403. ;;; load the backquote facility
  1404. (require :backquote)        ; cause this to be loaded now
  1405.  
  1406. ;;; load the format facility
  1407. (require :format)            ; cause this to be loaded now
  1408.  
  1409. ; (require :cl-working)        ; additional stuff
  1410.                 
  1411. ;
  1412. ;    This allows the #{ (assembly code) } syntax
  1413. ;
  1414. (set-dispatch-macro-character #¥# #¥{ 
  1415.     #'(lambda (stream char int)
  1416.         (require :assembler)
  1417.         (let ((*package* (find-package :assembler))) 
  1418.             (assemble (read-delimited-list #¥} stream) nil))))
  1419.  
  1420. (defun defasm (&rest x)
  1421.     (error "Assembler package not loaded"))
  1422.  
  1423. (defun hex (x) (format t "~x~%" x) (values))
  1424.  
  1425. (defun disassemble (a) 
  1426.     (let ((*print-base* 16)) 
  1427.         (format t "~{~A~%~}" (disassembly-list a))))
  1428.  
  1429. ;; Print an executable address in hex
  1430. (defun print-code (x) (hex (exec-address x)))
  1431.  
  1432. ;; Print an object address in hex
  1433. (defun print-addr (x) (hex (address x)))
  1434.         
  1435. (defvar *gc-hook* nil)
  1436. (defvar *gc-verbose* nil)
  1437.  
  1438. (defun ffloor (number &optional (divisor 1))
  1439.     (multiple-value-bind (num div) 
  1440.         (floor number divisor)
  1441.         (values (float num) div)))
  1442.  
  1443. (defun fceiling (number &optional (divisor 1))
  1444.     (multiple-value-bind (num div) 
  1445.         (ceiling number divisor)
  1446.         (values (float num) div)))
  1447.  
  1448. (defun ftruncate (number &optional (divisor 1))
  1449.     (multiple-value-bind (num div) 
  1450.         (truncate number divisor)
  1451.         (values (float num) div)))
  1452.  
  1453. (defun fround (number &optional (divisor 1))
  1454.     (multiple-value-bind (num div) 
  1455.         (round number divisor)
  1456.         (values (float num) div)))
  1457.  
  1458. (defun get-properties (place indicator-list)
  1459.     (do ((n place (cddr n)))
  1460.         ((< (length n) 2) (values nil nil nil))
  1461.         (let ((x (member (car n) indicator-list)))
  1462.             (if x
  1463.                 (return (values (car n) (cadr n) n))))))
  1464.  
  1465. (defun copy-symbol (sym &optional copy-props)
  1466.     (let ((new-symbol (make-symbol (symbol-name sym))))
  1467.         (if copy-props
  1468.             (progn
  1469.                 (if (boundp sym)
  1470.                     (setf (symbol-value new-symbol) (symbol-value sym)))
  1471.                 (setf (symbol-plist new-symbol) (copy-list (symbol-plist sym)))))
  1472.         new-symbol))
  1473.  
  1474. ;
  1475. ;    Set up the reader macro which allows for #:sym syntax
  1476. ;
  1477. (set-dispatch-macro-character #¥# #¥: 
  1478.     #'(lambda (stream char int)
  1479.         (let ((*package* nil))
  1480.             (read stream))))
  1481.  
  1482. (defsetf getf %setf-getf)
  1483.  
  1484. (defun error-stack () 
  1485.     "Usage: (error-stack)
  1486.         Prints a dump of the processor stack state when the last error 
  1487.         occurred"
  1488.     (dolist (i *stack-trace*) (print i)))
  1489.  
  1490. (defun signum (x)
  1491.    (cond ((not (numberp x)) (error "Not a number: ~A" x))
  1492.          ((zerop x) x)
  1493.           (t (/ x (abs x)))))
  1494.  
  1495. (defun phase (x)
  1496.     (if (not (numberp x)) (error "Not a number: ~A" x))
  1497.     (atan (imagpart x) (realpart x)))
  1498.  
  1499. (defmacro typecase (keyform &rest clauses)
  1500.     (let ((new-symbol (gensym)))
  1501.         (dolist (n clauses)
  1502.             (setf (car n) `(typep ,new-symbol ',(car n))))
  1503.         `(let ((,new-symbol ,keyform))
  1504.             (cond ,@clauses))))
  1505.  
  1506. (defun describe (obj)
  1507.     (require :describe)        ;; load module
  1508.     (cl::%describe obj))
  1509.  
  1510. (set-dispatch-macro-character #¥# #¥C 
  1511.     #'(lambda (stream char int)
  1512.         (let* ((*read-base* 10)
  1513.                (nums (read stream)))
  1514.             (complex (car nums) (cadr nums)))))
  1515.  
  1516. (defun cl::%do-symbols-get-symbol ()
  1517.     (prog* (sym flag)
  1518.         loop
  1519.         (if (null *do-symbols-packages*) (return (values nil nil)))
  1520.         (multiple-value-setq (sym flag) 
  1521.             (%package-next-symbol (car *do-symbols-packages*)))
  1522.         (unless flag 
  1523.             (progn
  1524.                 (setq *do-symbols-packages* (cdr *do-symbols-packages*))
  1525.                 (if (null *do-symbols-packages*) (return (values nil nil)))
  1526.                 (multiple-value-setq (sym flag) 
  1527.                     (%package-first-symbol (car *do-symbols-packages*)))))
  1528.         (if flag (return (values sym t)))
  1529.         (go loop)))
  1530.  
  1531. (defmacro do-symbols ((var package result-form) &rest forms)
  1532.     `(let ((pk (find-package ,package)) 
  1533.             packs 
  1534.             *do-symbols-packages*)
  1535.         (declare (special *do-symbols-packages*))
  1536.         (unless pk (setq pk *package*))
  1537.         (setq *do-symbols-packages* (cons pk (package-use-list pk)))
  1538.         (do* ((,var (%package-first-symbol pk) (cl::%do-symbols-get-symbol)))
  1539.              ((null *do-symbols-packages*) (progn (setq ,var nil) ,result-form))
  1540.              ,@forms)))
  1541.  
  1542. (defmacro do-all-symbols ((var result-form) &rest forms)
  1543.     `(let (*do-symbols-packages*)
  1544.         (declare (special *do-symbols-packages*))
  1545.         (setq *do-symbols-packages* (list-all-packages))
  1546.         (do* ((,var (%package-first-symbol (car *do-symbols-packages*)) 
  1547.                 (cl::%do-symbols-get-symbol)))
  1548.              ((null *do-symbols-packages*) (progn (setq ,var nil) ,result-form))
  1549.              ,@forms)))
  1550.  
  1551. (defun cl::%do-external-symbols-get-symbol ()
  1552.     (prog* (sym flag)
  1553.         loop
  1554.         (if (null *do-symbols-packages*) (return (values nil nil)))
  1555.         (multiple-value-setq (sym flag) 
  1556.             (%package-next-extern-symbol (car *do-symbols-packages*)))
  1557.         (unless flag 
  1558.             (progn
  1559.                 (setq *do-symbols-packages* (cdr *do-symbols-packages*))
  1560.                 (if (null *do-symbols-packages*) (return (values nil nil)))
  1561.                 (multiple-value-setq (sym flag) 
  1562.                     (%package-first-extern-symbol (car *do-symbols-packages*)))))
  1563.         (if flag (return (values sym t)))
  1564.         (go loop)))
  1565.  
  1566. (defmacro do-external-symbols ((var package result-form) &rest forms)
  1567.     `(let ((pk (find-package ,package)) 
  1568.             packs 
  1569.             *do-symbols-packages*)
  1570.         (declare (special *do-symbols-packages*))
  1571.         (unless pk (setq pk *package*))
  1572.         (setq *do-symbols-packages* (cons pk (package-use-list pk)))
  1573.         (do* ((,var (%package-first-extern-symbol pk) 
  1574.                 (cl::%do-external-symbols-get-symbol)))
  1575.              ((null *do-symbols-packages*) (progn (setq ,var nil) ,result-form))
  1576.              ,@forms)))
  1577.  
  1578. (defun find-all-symbols (name &aux (list nil))
  1579.     (if (symbolp name) (setq name (symbol-name name)))
  1580.     (do-all-symbols (x) 
  1581.         (if (string= (symbol-name x) name) (push x list)))
  1582.     list)
  1583.  
  1584. ;; Hyperbolic functions    Ken Whedbee  from CLtL
  1585.  
  1586. (defun logtest (x y) (not (zerop (logand x y))))
  1587. (defconstant imag-one #C(0.0 1.0))
  1588. (defun cis (x) (exp (* imag-one x)))
  1589.  
  1590. (defun asinh (x) (log (+ x (sqrt (+ 1.0 (* x x))))))
  1591. (defun acosh (x) (log (+ x (* (1+ x) (sqrt (/ (1- x) (1+ x)))))))
  1592. (defun atanh (x)
  1593.     (when (or (= x 1.0) (= x -1.0))
  1594.         (error "logarithmic singularity" x))
  1595.     (log (/ (1+ x) (sqrt (- 1.0 (* x x))))))
  1596.  
  1597. (defun butlast (x &optional (n 1))
  1598.     (let ((length (- (length x) n)))
  1599.         (if (minusp n)
  1600.             (error "butlast: negative index"))
  1601.         (if (<= length 0)
  1602.             nil
  1603.             (subseq x 0 length))))
  1604.  
  1605. (defun nbutlast (x &optional (n 1))
  1606.     (let ((length (- (length x) n)))
  1607.         (if (minusp n)
  1608.             (error "nbutlast: negative index"))
  1609.         (if (<= length 0)
  1610.             nil
  1611.             (progn
  1612.                 (setf (cdr (nthcdr (1- length) x)) nil)
  1613.                 x))))
  1614.  
  1615. (defun list-length (x)
  1616.     (do ((n 0 (+ n 2))
  1617.          (fast x (cddr fast))
  1618.          (slow x (cddr slow)))
  1619.         (nil)
  1620.         (when (endp fast) (return n))
  1621.         (when (endp (cdr fast)) (return (+ n 1)))
  1622.         (when (and (eq fast slow) (> n 0)) (return nil))))
  1623.  
  1624. (defsetf subseq (sequence start &optional end) (new-sequence)
  1625.     `(progn 
  1626.         (replace ,sequence ,new-sequence 
  1627.                 :start1 ,start :end1 ,end)
  1628.         ,new-sequence))
  1629.         
  1630. (defmacro declaim (&rest decl-specs)
  1631.     `(eval-when (:compile-toplevel :load-toplevel :execute)
  1632.         (mapcar #'proclaim ',decl-specs)))
  1633.  
  1634. (defun string-left-trim (char-bag string)
  1635.     (let* ((s (string string))
  1636.           (start-index 0))
  1637.         ;; trim off leading characters
  1638.         (do* ((c (char s start-index) (char s start-index)))
  1639.              ((not (find c char-bag)))
  1640.              (incf start-index))
  1641.         (subseq s start-index (length s))))
  1642.  
  1643. (defun string-right-trim (char-bag string)
  1644.     (let* ((s (string string))
  1645.           (end-index (1- (length s))))
  1646.         ;; trim off trailing characters
  1647.         (do* ((c (char s end-index) (char s end-index)))
  1648.              ((not (find c char-bag)))
  1649.              (decf end-index))
  1650.         (subseq s 0 (1+ end-index))))
  1651.  
  1652. (defun string-trim (char-bag string)
  1653.     (string-left-trim char-bag (string-right-trim char-bag string)))
  1654.  
  1655. (defun remove-duplicates (sequence 
  1656.         &key from-end (test #'eql) test-not (start 0) end (key #'identity))
  1657.     (unless (typep sequence 'sequence) 
  1658.         (error "Not a sequence: ~A" sequence))
  1659.     (unless (integerp end) 
  1660.         (setq end (length sequence)))
  1661.     (if test-not (setq test #'(lambda (x y) (not (funcall test-not x y)))))
  1662.  
  1663.     (let ((result (copy-seq sequence)))
  1664.         (if from-end
  1665.             ;; loop backward
  1666.             (do ((i (1- end) (- i 1)) 
  1667.                  (x))
  1668.                 ((< i start) nil)
  1669.                 (setq x (elt sequence i))
  1670.                 (let ((pos (position x sequence 
  1671.                             :test test
  1672.                             :from-end t 
  1673.                             :start start
  1674.                             :end i
  1675.                             :key key)))
  1676.                     (if (integerp pos)
  1677.                         (setq result
  1678.                             (remove x result
  1679.                                 :test test
  1680.                                 :from-end t
  1681.                                 :start start
  1682.                                 :end end
  1683.                                 :count 1
  1684.                                 :key key)))))  
  1685.  
  1686.             ;;; else go forward
  1687.             (do ((i start (+ i 1)) 
  1688.                  (x))
  1689.                 ((>= i end) nil)
  1690.                 (setq x (elt sequence i))
  1691.                 (let ((pos (position x sequence 
  1692.                             :test test 
  1693.                             :start (+ i 1)
  1694.                             :end end
  1695.                             :key key)))
  1696.                     (if (integerp pos)
  1697.                         (setq result
  1698.                             (remove x result
  1699.                                 :test test
  1700.                                 :start start
  1701.                                 :end (+ i 1)
  1702.                                 :count 1
  1703.                                 :key key))))))  
  1704.         result))
  1705.  
  1706. (setf (symbol-function 'delete-duplicates) (symbol-function 'remove-duplicates))
  1707.  
  1708. (defun y-or-n-p (&optional format-string &rest arguments)
  1709.     (let ((stream *query-io*)
  1710.           response)
  1711.         (if format-string
  1712.             (progn
  1713.                 (fresh-line stream)
  1714.                 (apply #'format stream format-string arguments)))
  1715.         (format stream "(Y/N)~%")
  1716.         (do ((response-char))
  1717.             (nil nil)            
  1718.             (setq response-char (char-upcase (read-char stream)))
  1719.             (cond
  1720.                 ((not (graphic-char-p response-char))) 
  1721.                 ((eq response-char #¥Y) (return-from y-or-n-p t))
  1722.                 ((eq response-char #¥N) (return-from y-or-n-p nil))
  1723.                 (t (format stream "(Y/N)~%"))))))
  1724.  
  1725. (defun yes-or-no-p (&optional format-string &rest arguments)
  1726.     (let ((stream *query-io*)
  1727.           response)
  1728.         (if format-string
  1729.             (progn
  1730.                 (fresh-line stream)
  1731.                 (apply #'format stream format-string arguments)))
  1732.         (format stream "(Yes/No)~%")
  1733.         (do ((response))
  1734.             (nil nil)            
  1735.             (setq response (read stream))
  1736.             (cond
  1737.                 ((eq response 'yes) (return-from yes-or-no-p t))
  1738.                 ((eq response 'no) (return-from yes-or-no-p nil))
  1739.                 (t (format stream "(Yes/No)~%"))))))
  1740.  
  1741. (defun values-list (list) (apply #'values list))
  1742.  
  1743. (require :setf)                    ;; load the setf facility
  1744. (require :random)                ;; load the random facility
  1745. (require :documentation)        ;; load documentation package
  1746.  
  1747.  
  1748.  
  1749.  
  1750.  
  1751.  
  1752.  
  1753.  
  1754.  
  1755.  
  1756.  
  1757.  
  1758.  
  1759.  
  1760.  
  1761.  
  1762.  
  1763.  
  1764.  
  1765.  
  1766.  
  1767.  
  1768.  
  1769.  
  1770.  
  1771.  
  1772.  
  1773.  
  1774.  
  1775.  
  1776.  
  1777.  
  1778.  
  1779.  
  1780.  
  1781.  
  1782.  
  1783.  
  1784.  
  1785.  
  1786.  
  1787.  
  1788.  
  1789.  
  1790.  
  1791.  
  1792.  
  1793.  
  1794.  
  1795.  
  1796.